home *** CD-ROM | disk | FTP | other *** search
/ Whiteline: Alpha / Whiteline Alpha.iso / progtool / modula2 / hk_lib / def_mod / screen.mod < prev    next >
Encoding:
Modula Implementation  |  1994-09-22  |  12.5 KB  |  454 lines
  1. IMPLEMENTATION MODULE  Screen;
  2.  
  3. (*****************************************************************************)
  4. (* Es werden einfach nur die Escapesequenzen an die Terminalemulation ausge- *)
  5. (* geben, dies geschieht direkt ueber die Betriebssystemfunktion 'Bconout',  *)
  6. (* da eine Umlenkung auf Dateien oder andere Geraete nicht sinnvoll waere.   *)
  7. (* Einige Funktionen lassen sich auch nur direkt ueber Betriebssystemfunkti- *)
  8. (* onen erreichen.                                                           *)
  9. (*___________________________________________________________________________*)
  10. (*   05-Jan-90 , hk                                                          *)
  11. (*         Beginn                                                            *)
  12. (*   26-Jan-90 , hk                                                          *)
  13. (*         erste Version                                                     *)
  14. (*   30-Jan-90 , hk                                                          *)
  15. (*         "WriteStr", "WriteConStr", "WriteRawConStr" neu                   *)
  16. (*   05-Mae-90 , hk                                                          *)
  17. (*         Traps aus "TRAPdefs" importiert                                   *)
  18. (*****************************************************************************)
  19.  
  20. FROM  SYSTEM    IMPORT  (* PROC *) REG, VAL, INLINE;
  21.  
  22. FROM  TRAPdefs  IMPORT  (* CONST*) d0,
  23.                         (* PROC *) BIOS2w, XBIOS2w, GEMDOS1w;
  24.  
  25. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
  26.  
  27. CONST  Bconout  = 3;   (* BIOS-Funktionsnummer  *)
  28.        Cursconf = 21;  (* XBIOS-Funktionsnummer *)
  29.        Cconout  = 2;   (* GEMDOS-Funktionsnr.   *)
  30.  
  31.        VBlankRate = 14;(* in ms bei Schwarzweiss   *)
  32.  
  33. VAR  BlinkRate : CARDINAL;
  34.  
  35. (*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
  36.  
  37. (* Hier erst mal einige Funktionen, die nicht ueber die
  38.    ESCAPE-Sequenzen der Terminalemulation implementiert
  39.    werden, sondern direkte Betriebssystemeaufrufe sind.
  40.  *)
  41.  
  42.   PROCEDURE  WriteRawCon ((* EIN/ -- *) zeichen : CHAR );
  43. (*T*)
  44.    CONST  RAWCON  = 5;  (* Geraet: Konsole ohne Terminalemulation  *)
  45.  
  46.    BEGIN
  47.      BIOS2w( ORD( zeichen ), RAWCON, Bconout );
  48.   END  WriteRawCon;
  49.  
  50. (*---------------------------------------------------------------------------*)
  51.  
  52.   PROCEDURE  WriteCon ((* EIN/ -- *) zeichen : CHAR );
  53. (*T*)
  54.    CONST  CON  = 2;  (* Geraet: Konsole mit Terminalemulation *)
  55.  
  56.    BEGIN
  57.      BIOS2w( ORD( zeichen ), CON, Bconout );
  58.   END  WriteCon;
  59.  
  60. (*---------------------------------------------------------------------------*)
  61.  
  62.   PROCEDURE  WriteChar ((* EIN/ -- *) zeichen : CHAR );
  63. (*T*)
  64.     BEGIN
  65.       GEMDOS1w( ORD( zeichen ), Cconout );
  66.     END  WriteChar;
  67.  
  68. (*---------------------------------------------------------------------------*)
  69.  
  70.   PROCEDURE  WriteRawConStr ((* EIN/ -- *) string : ARRAY OF CHAR );
  71. (*T*)
  72.      BEGIN
  73. (*
  74.        RAWCON  EQU 5              ; Geraetenummer
  75.        Bconout EQU 3              ; BIOS-Funktionsnummer
  76.        BIOS    EQU 13             ; Nummer des TRAPs
  77.  
  78.        string  EQU 12             ; Offsets der Parameter
  79.        HIGH    EQU string + 4     ;
  80.  
  81.        WriteRawConStr:
  82.          movea.l string(a6), a3   ; a3 -> <string>
  83.          move.w  HIGH(a6), d3     ; d3 := HIGH(string);
  84.          moveq   #0, d4           ; auszugebendes Zeichen auf Wortlaenge
  85.                                   ; a3, d3, d4 werden durch Betriebssystem-
  86.                                   ; funktionen nicht veraendert ( hoffentlich )
  87.        wrtlp:
  88.          move.b  (a3)+, d4        ; d4 := naechstes auszugebendes Zeichen
  89.          beq.s   ende             ; B: Ende des Strings ( dynamisch )
  90.          move.w  d4, -(sp)
  91.          move.w  #RAWCON, -(sp)
  92.          move.w  #Bconout, -(sp)
  93.          trap    #BIOS
  94.          addq.l  #6, sp           ; innerhalb einer Schleife lieber Stackkor.
  95.          dbra    d3, wrtlp        : B: String noch nicht zuende ( statisch )
  96.        ende:
  97. *)
  98.        INLINE( 266EH,000CH,362EH,0010H,7800H,181BH,6712H,3F04H,3F3CH );
  99.        INLINE( 0005H,3F3CH,0003H,4E4DH,5C8FH,51CBH,0FFECH );
  100.  
  101.      END  WriteRawConStr;
  102.  
  103. (*---------------------------------------------------------------------------*)
  104.  
  105.   PROCEDURE  WriteConStr ((* EIN/ -- *) string : ARRAY OF CHAR );
  106. (*T*)
  107.      BEGIN
  108. (*
  109.        CON     EQU 2
  110.        Bconout EQU 3
  111.        BIOS    EQU 13
  112.  
  113.        string  EQU 12
  114.        HIGH    EQU string + 4
  115.  
  116.        WriteConStr:
  117.          movea.l string(a6), a3
  118.          move.w  HIGH(a6), d3
  119.          moveq   #0, d4
  120.        wrtlp:
  121.          move.b  (a3)+, d4
  122.          beq.s   ende
  123.          move.w  d4, -(sp)
  124.          move.w  #CON, -(sp)
  125.          move.w  #Bconout, -(sp)
  126.          trap    #BIOS
  127.          addq.l  #6, sp
  128.          dbra    d3, wrtlp
  129.        ende:
  130. *)
  131.        INLINE( 266EH,000CH,362EH,0010H,7800H,181BH,6712H,3F04H,3F3CH );
  132.        INLINE( 0002H,3F3CH,0003H,4E4DH,5C8FH,51CBH,0FFECH );
  133.  
  134.      END  WriteConStr;
  135.  
  136. (*---------------------------------------------------------------------------*)
  137.  
  138.   PROCEDURE  WriteStr ((* EIN/ -- *) string : ARRAY OF CHAR );
  139. (*T*)
  140.      VAR  Puffer : CHAR;
  141.  
  142.      BEGIN
  143. (*
  144.       GEMDOS EQU 1
  145.       Cconws EQU 9
  146.  
  147.       string EQU 12
  148.       HIGH   EQU string + 4
  149.  
  150.       WriteStr:
  151.         movea.l string(a6), a0
  152.         move.w  HIGH(a6), d0
  153.         clr.b   1(a0,d0.w)     ; damit ist der string auch mit einem
  154.                                ; Nullbyte abgeschlossen, wenn er das
  155.                                ; ganze Feld ausfuellt. Durch die lokale
  156.                                ; Variable ist hinter <string> auf jeden
  157.                                ; Fall noch Platz.
  158.         move.l  a0, -(sp)      ; ADR( string )
  159.         move.w  #Cconws, -(sp) ; GEMDOS-Funktion auswaehlen...
  160.         trap    #GEMDOS        ;...und ausfuehren
  161.  
  162. *)
  163.       INLINE( 206EH,000CH,302EH,0010H,4230H,0001H,2F08H,3F3CH,0009H,4E41H );
  164.  
  165.      END  WriteStr;
  166.  
  167. (*---------------------------------------------------------------------------*)
  168.  
  169.   PROCEDURE  CursorOn;
  170. (*T*)
  171.    CONST  CursShow = 1;  (* Funktionsnummer *)
  172.  
  173.    BEGIN
  174.      XBIOS2w( 0, CursShow, Cursconf );
  175.   END  CursorOn;
  176.  
  177. (*---------------------------------------------------------------------------*)
  178.  
  179.   PROCEDURE  CursorOff;
  180. (*T*)
  181.    CONST  CursHide = 0;  (* Funktionsnummer *)
  182.  
  183.    BEGIN
  184.      XBIOS2w( 0, CursHide, Cursconf );
  185.   END  CursorOff;
  186.  
  187. (*---------------------------------------------------------------------------*)
  188.  
  189.   PROCEDURE  CursorBlinkOn;
  190. (*T*)
  191.    CONST  CursBlink = 2;  (* Funktionsnummer *)
  192.  
  193.    BEGIN
  194.      XBIOS2w( 0, CursBlink, Cursconf );
  195.   END  CursorBlinkOn;
  196.  
  197. (*---------------------------------------------------------------------------*)
  198.  
  199.   PROCEDURE  CursorBlinkOff;
  200. (*T*)
  201.    CONST  CursNoBlink = 3;  (* Funktionsnummer *)
  202.  
  203.    BEGIN
  204.      XBIOS2w( 0, CursNoBlink, Cursconf );
  205.   END  CursorBlinkOff;
  206.  
  207. (*---------------------------------------------------------------------------*)
  208.  
  209.   PROCEDURE  SetBlinkRate ((* EIN/ -- *) ms : CARDINAL );
  210. (*T*)
  211.    CONST  CursSetRate = 4;  (* Funktionsnummer  *)
  212.  
  213.    BEGIN
  214.      XBIOS2w( ms DIV ( VBlankRate * 2 ), CursSetRate, Cursconf );
  215.   END  SetBlinkRate;
  216.  
  217. (*---------------------------------------------------------------------------*)
  218.  
  219.   PROCEDURE  GetBlinkRate ((* -- /AUS *) VAR ms : CARDINAL );
  220. (*T*)
  221.    CONST  CursGetRate = 5;  (* Funktionsnummer    *)
  222.  
  223.    BEGIN
  224.      XBIOS2w( 0, CursGetRate, Cursconf );
  225.  
  226.      ms := VAL( CARDINAL, REG( d0 )) * VBlankRate * 2;
  227.   END  GetBlinkRate;
  228.  
  229. (*---------------------------------------------------------------------------*)
  230.  
  231.   PROCEDURE  RestoreBlinkRate;
  232. (*T*)
  233.    CONST  CursSetRate = 4;  (* Funktionsnummer  *)
  234.  
  235.    BEGIN
  236.      XBIOS2w( BlinkRate, CursSetRate, Cursconf );
  237.   END  RestoreBlinkRate;
  238.  
  239. (*---------------------------------------------------------------------------*)
  240.  
  241. PROCEDURE  Escape ((* EIN/ -- *) funktion : CHAR );
  242. (*T*)
  243.   CONST  ESC = 33C;
  244.  
  245. BEGIN
  246.   WriteCon( ESC );
  247.   WriteCon( funktion );
  248. END  Escape;
  249.  
  250. (*===========================================================================*)
  251.  
  252.   PROCEDURE  CursorUp;
  253. (*T*)
  254.    BEGIN
  255.      Escape('A');
  256.    END  CursorUp;
  257.  
  258. (*---------------------------------------------------------------------------*)
  259.  
  260.   PROCEDURE  CursorUpScroll;
  261. (*T*)
  262.    BEGIN
  263.      Escape('I');
  264.    END  CursorUpScroll;
  265.  
  266. (*---------------------------------------------------------------------------*)
  267.  
  268.   PROCEDURE  CursorDown;
  269. (*T*)
  270.    BEGIN
  271.      Escape('B');
  272.    END  CursorDown;
  273.  
  274. (*---------------------------------------------------------------------------*)
  275.  
  276.   PROCEDURE  CursorRight;
  277. (*T*)
  278.    BEGIN
  279.      Escape('C');
  280.    END  CursorRight;
  281.  
  282. (*---------------------------------------------------------------------------*)
  283.  
  284.   PROCEDURE  CursorLeft;
  285. (*T*)
  286.    BEGIN
  287.      Escape('D');
  288.    END  CursorLeft;
  289.  
  290. (*---------------------------------------------------------------------------*)
  291.  
  292.   PROCEDURE  CursorHome;
  293. (*T*)
  294.    BEGIN
  295.      Escape('H');
  296.    END  CursorHome;
  297.  
  298. (*---------------------------------------------------------------------------*)
  299.  
  300.   PROCEDURE  ClearScreen;
  301. (*T*)
  302.    BEGIN
  303.      Escape('E');
  304.    END  ClearScreen;
  305.  
  306. (*---------------------------------------------------------------------------*)
  307.  
  308.   PROCEDURE  EraseToEndOfPage;
  309. (*T*)
  310.    BEGIN
  311.      Escape('J');
  312.    END  EraseToEndOfPage;
  313.  
  314. (*---------------------------------------------------------------------------*)
  315.  
  316.   PROCEDURE  EraseToEndOfLine;
  317. (*T*)
  318.    BEGIN
  319.      Escape('K');
  320.    END  EraseToEndOfLine;
  321.  
  322. (*---------------------------------------------------------------------------*)
  323.  
  324.   PROCEDURE  EraseLine;
  325. (*T*)
  326.    BEGIN
  327.      Escape('l');
  328.    END  EraseLine;
  329.  
  330. (*---------------------------------------------------------------------------*)
  331.  
  332.   PROCEDURE  EraseToStartOfPage;
  333. (*T*)
  334.    BEGIN
  335.      Escape('d');
  336.    END  EraseToStartOfPage;
  337.  
  338. (*---------------------------------------------------------------------------*)
  339.  
  340.   PROCEDURE  EraseToStartOfLine;
  341. (*T*)
  342.    BEGIN
  343.      Escape('o');
  344.    END  EraseToStartOfLine;
  345.  
  346. (*---------------------------------------------------------------------------*)
  347.  
  348.   PROCEDURE  InsertLine;
  349. (*T*)
  350.    BEGIN
  351.      Escape('L');
  352.    END  InsertLine;
  353.  
  354. (*---------------------------------------------------------------------------*)
  355.  
  356.   PROCEDURE  DeleteLine;
  357. (*T*)
  358.    BEGIN
  359.      Escape('M');
  360.    END  DeleteLine;
  361.  
  362. (*---------------------------------------------------------------------------*)
  363.  
  364.   PROCEDURE  GotoXY ((* EIN/ -- *) spalte,
  365.                      (* EIN/ -- *) zeile  : CARDINAL );
  366. (*T*)
  367.    BEGIN
  368.      (* Erst mal auf korrekte Laenge stutzen
  369.       *)
  370.      IF  zeile  > 24  THEN  zeile := 24;  END;
  371.      IF  spalte > 79  THEN  zeile := 79;  END;
  372.  
  373.      Escape('Y');
  374.      WriteCon( CHR( 32 + zeile ));
  375.      WriteCon( CHR( 32 + spalte ));
  376.  
  377.    END  GotoXY;
  378.  
  379. (*---------------------------------------------------------------------------*)
  380.  
  381.   PROCEDURE  SaveCursorPos;
  382. (*T*)
  383.    BEGIN
  384.      Escape('j');
  385.    END  SaveCursorPos;
  386.  
  387. (*---------------------------------------------------------------------------*)
  388.  
  389.   PROCEDURE  RestoreCursorPos;
  390. (*T*)
  391.    BEGIN
  392.      Escape('k');
  393.    END  RestoreCursorPos;
  394.  
  395. (*---------------------------------------------------------------------------*)
  396.  
  397.   PROCEDURE  AutoWrapOn;
  398. (*T*)
  399.    BEGIN
  400.      Escape('v');
  401.    END  AutoWrapOn;
  402.  
  403. (*---------------------------------------------------------------------------*)
  404.  
  405.   PROCEDURE  AutoWrapOff;
  406. (*T*)
  407.    BEGIN
  408.      Escape('w');
  409.    END  AutoWrapOff;
  410.  
  411. (*---------------------------------------------------------------------------*)
  412.  
  413.   PROCEDURE  InverseOn;
  414. (*T*)
  415.    BEGIN
  416.      Escape('p');
  417.    END  InverseOn;
  418.  
  419. (*---------------------------------------------------------------------------*)
  420.  
  421.   PROCEDURE  InverseOff;
  422. (*T*)
  423.    BEGIN
  424.      Escape('q');
  425.    END  InverseOff;
  426.  
  427. (*---------------------------------------------------------------------------*)
  428.  
  429.   PROCEDURE  SetForegroundColor ((* EIN/ -- *) farbe : CARDINAL );
  430. (*T*)
  431.    BEGIN
  432.      Escape('b'); WriteCon( CHR( 30H + ( farbe MOD 16 )));
  433.    END  SetForegroundColor;
  434.  
  435.  
  436. (*---------------------------------------------------------------------------*)
  437.  
  438.   PROCEDURE  SetBackgroundColor ((* EIN/ -- *) farbe : CARDINAL );
  439. (*T*)
  440.    BEGIN
  441.      Escape('c'); WriteCon( CHR( 30H + ( farbe MOD 16 )));
  442.    END  SetBackgroundColor;
  443.  
  444.  
  445.  
  446. (*===========================================================================*)
  447.  
  448. BEGIN (* Screen *)
  449.  
  450.   XBIOS2w( 0, 5, Cursconf );
  451.   BlinkRate := REG( d0 );
  452.  
  453. END  Screen.
  454.